home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 2003 August / MW 8 2003 CD1.iso / Inside Macworld / Product News / gimp-1.2.4.sit / gimp-1.2.4 / plug-ins / perl / scm2scm < prev    next >
Encoding:
Text File  |  2000-03-28  |  7.4 KB  |  338 lines
  1. #!/usr/bin/perl
  2.  
  3. use 5.005;
  4.  
  5. $VERSION = 1.0;
  6.  
  7. # Copyright Marc Lehmann <pcg@goof.com>
  8. #
  9. # This is distributed under the GPL (see COPYING.GNU for details).
  10.  
  11. =cut
  12.  
  13. =head1 NAME
  14.  
  15. scm2scm - convert script-fu to script-fu
  16.  
  17. =head1 SYNOPSIS
  18.  
  19.  scm2scm [-d] [-t translation]... filename.scm...
  20.  
  21. =head1 DESCRIPTION
  22.  
  23. This perl-script can be used to upgrade existing script-fu-scripts to
  24. newer gimp API's.
  25.  
  26. =head1 EXAMPLES
  27.  
  28. Convert all script-fu scripts in the current directory from the 1.0 to the
  29. 1.2 API (creating new files with the extension .sc2):
  30.  
  31.  scm2scm -t 1.2 *.scm
  32.  
  33. Generate a diff containing the required changes from the 1.0
  34. to the 1.1-API:
  35.  
  36.  scm2scm -d -t 1.1 test.scm
  37.  
  38. =head1 SWITCHES
  39.  
  40. =over 4
  41.  
  42. =item -d
  43.  
  44. generate a unified diff on stdout
  45.  
  46. =item -t translation id
  47.  
  48. specify a translation id, can be one of (run scm2scm without arguments
  49. to see the full list)
  50.  
  51. I<api1>    api-mega-break-patch #1
  52. I<api2> api-mega-rename-patch #1 (NYI)
  53.  
  54. I<1.1>    1.0 -> 1.1 (not fully implemented)
  55.  
  56. I<1.2>    1.0 -> 1.2 (not fully implemented)
  57.  
  58. =back
  59.  
  60. =head1 AUTHOR
  61.  
  62. Marc Lehmann <pcg@goof.com>
  63.  
  64. =head1 SEE ALSO
  65.  
  66. gimp(1), L<Gimp>.
  67.  
  68. =cut
  69.  
  70. # Fixes names of functions by swapping last two parts of the name
  71. # eg. gimp-image-disable-undo becomes gimp-image-undo-disable
  72. # Whitespace is preserved(!)
  73. sub swap_last_two {
  74.   my($a,$f,$t1,$t2,@t)=@_;
  75.   $f->[1] =~ s/(\w+)-(\w+)-(\w+)-(\w+)/$1-$2-$4-$3/;
  76.   ($a,$f,new token($t1->[0],$t1->[1],$t2->[1]),@t);
  77. }
  78.  
  79. # drop the first argument, while preserving correct whitespace(!)
  80. sub drop_1st {
  81.   my($a,$f,$t1,$t2,@t)=@_;
  82.   ($a,$f,new token($t1->[0],$t2->[1],$t2->[2]),@t);
  83. }
  84.  
  85. # "nicify" plug-in constants
  86. sub plug_in_constant {
  87.   my($a,$f,$t1,$t2,@t)=@_;
  88.   my $n = $t2->[1];
  89.   $n==0 and $n = "RUN_NONINTERACTIVE";
  90.   ($a,$f,new token($t1->[0],$n,$t2->[2]),@t);
  91. }
  92.  
  93. # every hash value consists of an array of specifications, each
  94. # one has the form ["regexp", codref_to_call], or a string (another translation
  95. # name)
  96. %translation = (
  97.    'api1' =>
  98.       [
  99.        [
  100.         "^(gimp-airbrush|gimp-blend|gimp-brightness-contrast|gimp-bucket-fill|".
  101.         "gimp-by-color-select|gimp-channel-ops-offset|gimp-clone|gimp-color-balance|".
  102.         "gimp-color-picker|gimp-convolve|gimp-curves-explicit|gimp-curves-spline|".
  103.         "gimp-desaturate|gimp-edit-clear|gimp-edit-copy|gimp-edit-cut|gimp-edit-fill|".
  104.         "gimp-edit-paste|gimp-edit-stroke|gimp-equalize|gimp-eraser|".
  105.         "gimp-eraser-extended|gimp-flip|gimp-fuzzy-select|gimp-histogram|".
  106.         "gimp-hue-saturation|gimp-invert|gimp-levels|gimp-paintbrush|".
  107.         "gimp-paintbrush-extended|gimp-pencil|gimp-perspective|gimp-posterize|".
  108.         "gimp-rotate|gimp-scale|gimp-selection-float|gimp-selection-layer-alpha|".
  109.         "gimp-selection-load|gimp-shear|gimp-threshold)\$",
  110.         \&drop_1st
  111.        ]
  112.       ],
  113.    'api2' =>
  114.       [
  115.        [
  116.         "^(gimp-image-disable-undo|gimp-image-enable-undo)\$",
  117.         \&swap_last_two
  118.        ]
  119.       ],
  120.    '1.1' => ['nice','api1','api2'],
  121.    '1.2' => ['nice','api1','api2'],
  122.    'nice'=> [],#["^(plug-in-|file-|gimp-file-)", \&plug_in_constant]],
  123. );
  124.  
  125. $gen_diff=0;
  126. @trans = ();
  127.  
  128. package token;
  129.  
  130. sub new {
  131.    my $type = shift;
  132.    bless [@_],$type;
  133. }
  134.  
  135. package main;
  136.  
  137. my $stream;    # the stream to tokenize from
  138. my $word;    # the current token-word
  139. my $tok;    # current token
  140.  
  141. # parses a new token [ws, tok, ws]
  142. sub get() {
  143.    my($ws1,$ctk,$ws2);
  144.    # could be wrapped into one regex
  145.    $ws1 = $stream=~s/^((?:\s*(?:(;[^\n]*\n))?)*)// ? $1 : die;
  146.    $ctk = $stream=~s/^(\(
  147.                       |\)
  148.                       |"(?:[^"]+|\\")*"
  149.                       |'(?:[^()]+)
  150.                       |[^ \t\r\n()]+
  151.                       )
  152.                       (?:[ \t]*(?=\n))?//x ? $1 : undef;
  153.    $ws2 = $stream=~s/^([ \t]*;[^\n]*\n)// ? $1 : "";
  154.    $word=$ctk;
  155.    
  156. #   print "TOKEN:$ws1:$ctk:$ws2\n";
  157.    $tok=new token($ws1,$ctk,$ws2);
  158. }
  159.  
  160. # returns a parse tree, which is an array
  161. # of [token, token...] refs.
  162. sub parse() {
  163.    my @toks;
  164.    $depth++;
  165.    for(;;) {
  166. #      print "$depth: $word\n";
  167.       if ($word eq "(") {
  168.          my $t = $tok; get;
  169.          my @t = &parse;
  170.          $word eq ")" or die "missing right parenthesis (got $word)\n";
  171.          push(@toks,[$t,@t,$tok]); get;
  172.       } elsif ($word eq ")") {
  173.          $depth--;
  174.          return @toks;
  175.       } elsif (!defined $word) {
  176.          $depth--;
  177.          return @toks;
  178.       } else {
  179.          push(@toks,$tok);
  180.          get;
  181.       }
  182.    }
  183. }
  184.  
  185. sub parse_scheme {
  186.    get;
  187.    my @t = parse;
  188.    (@t,$tok);
  189. }
  190.  
  191. # dumb dump of the tree structure
  192. sub dump_tree {
  193.    my $d=shift;
  194.    print "$d",scalar@_;
  195.    for(@_) {
  196.       if (isa($_,token)) {
  197.          print " [$_->[1]]";
  198.       } else {
  199.          print " *";
  200.       }
  201.    }
  202.    print "\n";
  203.    for(@_) {
  204.       if(!isa($_,token)) {
  205.          dump_tree ("$d   ",@$_);
  206.       }
  207.    }
  208. }
  209.  
  210. sub toks2scheme {
  211.    my $func = shift;
  212.    if ($func->[1] eq "(") {
  213.       my $close = shift;
  214. #      func2scheme @_;
  215.    } else {
  216.    }
  217.    while(@_) {
  218.       my @toks = shift;
  219.       my ($unused,$t,$ws1)=$toks[0]
  220.    }
  221.    
  222. }
  223.  
  224. sub tree2scheme {
  225.    join ("",map isa($_,token) ? @$_ : tree2scheme(@$_),@_);
  226. }
  227.  
  228. sub scheme2perl {
  229.    for(@_) {
  230.       local $_ = shift;
  231.       print scalar@_,">\n";
  232.       local *_ = \$_[0];
  233.       print "$_=\n";
  234.       if (isa($_,token)) {
  235.          my $t = $_->[1];
  236.          $_->[0] =~ s/^(\s*);/$1#/mg;
  237.          $_->[1] =~ s/^(\s*);/$1#/mg;
  238.          if ($t eq "define") {
  239.             $_->[1] = "sub";
  240.             splice @{$_[$i+1]},2,-1,new token "","{","";
  241.             $_[$i+2]
  242.          } elsif ($t =~ /[()]/) {
  243.             $_->[1] = "";
  244.          } else {
  245.             $_[0] = [
  246.                      new token ("[",$_->[0],"<"),
  247.                      new token ("",$_->[1],">"),
  248.                      new token ("",$_->[2],"]"),
  249.                  ];
  250.          }
  251.       } else {
  252.          scheme2perl(@$_);
  253.       }
  254.       shift; print scalar@_,"<\n";
  255.    }
  256. }
  257.  
  258. # translate functions, sorry folks, this function is write-only!
  259. sub translate {
  260.    my $v=shift;
  261.    my @t=@_;
  262.    if (isa($t[0],token)) {
  263.       for(@$v) {
  264.          if ($t[1][1] =~ $_->[0]) {
  265.             @t=$_->[1]->(@t);
  266.          }
  267.       }
  268.    }
  269.    for(@t) {
  270.       $_=[translate($v,@$_)] unless isa($_,token);
  271.    }
  272.    @t;
  273. }
  274.  
  275. sub dofile {
  276.    my($in,$out)=@_;
  277.    
  278.    open IN,"$in"   or die "unable to open '$in' for reading: $!";
  279.    { local $/; $stream = <IN> }
  280.    close IN;
  281.    
  282.    my @prog = parse_scheme;
  283.    
  284.    if (@trans) {
  285.       my $changed;
  286.       do {
  287.          $changed=0;
  288.          @trans = map {
  289.             if (!ref $_) {
  290.                $changed=1;
  291.                @{$translation{$_}};
  292.             } else {
  293.                $_;
  294.             }
  295.          } @trans;
  296.       } while($changed);
  297.       @prog = translate ([@trans],@prog);
  298.    }
  299.    
  300.    open OUT,"$out" or die "unable to open '$out' for writing: $!";
  301.    #scheme2perl(@prog);
  302.    print OUT tree2scheme(@prog);
  303.    close OUT;
  304. }
  305.  
  306. *isa = \&UNIVERSAL::isa;
  307.  
  308. sub usage {
  309.    print STDERR "Script-Fu to Script-Fu Translater 1.1.1\n";
  310.    print STDERR "Usage: $0 [-d] [-t translation] file.scm ...\n";
  311.    print STDERR "available translations are: @{[keys %translation]}\n";
  312.    exit(1);
  313. }
  314.  
  315. while($ARGV[0]=~/^-(.)$/) {
  316.    shift;
  317.    if ($1 eq "d") {
  318.       $gen_diff=1;
  319.    } elsif ($1 eq "t") {
  320.       push(@trans,shift);
  321.    } else {
  322.      print STDERR "unknown switch '$1'\n";
  323.    }
  324. }
  325. @ARGV or usage;
  326.  
  327. for $x (@ARGV) {
  328.    my $y;
  329.    if ($gen_diff) {
  330.       $y="| echo Index: '$x' && diff -u '$x' -";
  331.    } else {
  332.       ($y=$x)=~s/\.scm/.sc2/i or die "source file '$x' has no .scm extension";
  333.       $y=">$y\0";
  334.    }
  335.    dofile("<$x\0",$y);
  336. }
  337.  
  338.